package Sokoban::Game;
use 5.014002;
use Storable qw(dclone freeze thaw);
use Data::Dump qw(dump);
use List::MoreUtils qw(any all first_index last_index true);
use List::Util qw(sum min max);
use Time::HiRes qw(tv_interval gettimeofday);
use Digest::MD5 qw(md5_hex);
use Carp;
use Sokoban::Parser;
use Sokoban::Handy ':all';
our @ISA     = qw(Sokoban::Parser);
our $VERSION = '3.0.0';
our $IDENTITY;
our %BADS;
our @start;
our $BADONE = [];
our @HEAP;
our %stat;

use constant {
    OLEFT  => 0,
    OUP    => 1,
    ORIGHT => 2,
    ODOWN  => 3,

    POZICE => 0,
    STEP   => 1,
    SOL    => 1,
    SCORE  => 2,
    DELKA  => 3,
    LEVEL  => 4,

    NO  => !1,
    YES => !0
};

sub new {
    my( $class, $hra ) = @_;
    my $self = $class->SUPER::new($hra);
    %INVALID  = ();
    %SEEN     = ();
    %TAHY = ();
    @POKR = ();
    @HEAP = ();

    $self->start;
    return $self;
}

sub isinvalid {
    my($self,$pozice) = @_;
    return YES unless $pozice;
    if(exists($INVALID{$pozice})) {

        return YES;
    }
    return NO;
}

sub badpatt {
    my($self,$box,$x) = @_;
    if ( $self->anyall( $box, $self->{maze}{$x}{patterns} ) ) {
        return YES;
    }

    return NO;
}
sub inbads {
    my($self,$box,$ply) = @_;
    foreach my $bad ( grep { $ply ~~ $_->[1]} @{$BADONE}) {
        if ($self->include($box,$bad->[0])) {
           return YES;
        }
    }
    return NO;
}

sub hasmove {
    my( $self, $cesty, $box, $x, $y, $z ) = @_;
    my @fail = (undef,undef);
    return @fail unless $self->canmove( $cesty, $box, $x, $y, $z );
    my $newbox = replace( $box, $x, $y );
    my $pozice = pozice( $newbox, $x );
    return @fail if ($self->isinvalid($pozice));

    if ( $self->badpatt( $newbox, $y ) ) {
        setinvalid($pozice);
        return @fail;
    }
    if ( $self->inbads( $newbox, $x ) ) {
        setinvalid($pozice);
        return @fail;
    }
    return ($newbox,$pozice);
}

sub pairs {
    my( $self, $x ) = @_;
    return @{ $self->{maze}{$x}{oo} };
}

sub tah {
    my( $self, $poz, $cesty, $box, $x, $yz ) = @_;
    my( $newbox, $pozice, $step, $sc, $y, $z );
    $y = $yz->[0];
    $z = $yz->[1];
    ($newbox,$pozice) = $self->hasmove( $cesty, $box, $x, $y, $z );
    return unless defined $newbox;
    $step = $cesty->{$z} . $self->{sm}{ $y - $x };
    $sc = $self->score($newbox,$y);

    delete $self->{unmovable}{$x};
    return [ $pozice, $step, $sc ];
}

sub movable {
    my( $self, $cesty, $box, $x, $yz ) = @_;
    my( $y, $z );
    $y = $yz->[0];
    $z = $yz->[1];
    return NO unless $self->canmove( $cesty, $box, $x, $y, $z );
    my $newbox = replace( $box, $x, $y );
    return NO if ( $self->badpatt( $newbox, $y ) );
    return YES;
}

sub nehybne {
    my( $self, $box, $ply ) = @_;
    my $cesty = $self->checkpath( $box, $ply );
    $self->{unm} = {};
    foreach my $bx ( @{$box} ) {
        $self->{unm}{$bx} = 1;
        if ( any { $_ == YES } map { $self->movable( $cesty, $box, $bx, $_ ) } $self->pairs($bx) ) {
            delete $self->{unm}{$bx};
        }
    }
    return ([ sort { $a <=> $b } keys delete $self->{unm} ],$cesty);
}

sub addbad {
    my($self,$pozice,$cesty,$zbytek) = @_;
    my( $box, $ply ) = boxply($pozice);
    my $key = md5_hex(join(',', @{$zbytek}) . '|' . join(',', sort {$a <=> $b} keys $cesty));
    $BADS{$key} = [$zbytek, [sort {$a <=> $b} keys $cesty] ];
    $BADONE = [ sort {$#{$a->[0]} <=> $#{$b->[0]} } values %BADS ];
}

sub analyze {
    my( $self, $pozice, $cesty, $zbytek, $ply ) = @_;
    my $paths;
    ($zbytek,$paths) = $self->nehybne( $zbytek, $ply );
    return if isempty($zbytek);

    my $check = dclone($zbytek);
    while ( isnotempty($zbytek) ) {
        if ( all { $_ ~~ $self->{target} } @{$zbytek} ) {
            $zbytek = [];
            last;
        }
        ($zbytek,$paths) =  $self->nehybne( $check, $ply );
        last if $zbytek ~~ $check;
        $check = dclone($zbytek);
    }
    return NO if isempty($zbytek);
    setinvalid($pozice);
    $self->addbad($pozice,$paths,$zbytek);
    return YES;
}

sub tahy {
    my( $self, $pozice ) = @_;
    my( $box, $ply, $cesty, @tahy );
    return () if $self->isinvalid($pozice);
    %TAHY = () if 256000 > scalar keys %TAHY;
    if ( exists $TAHY{$pozice} ) {
        return @{ thaw $TAHY{$pozice} };
    }

    ( $box, $ply ) = boxply($pozice);
    $cesty             = $self->cesty( $box, $ply );
    @tahy              = ();
    $self->{unmovable} = {};
    foreach my $bx ( @{$box} ) {
        $self->{unmovable}{$bx} = 1;
        push @tahy, grep { ref($_) } map { $self->tah( $pozice, $cesty, $box, $bx, $_ ) } $self->pairs($bx);
    }
    unless (@tahy) {
        setinvalid($pozice);
        return ();
    }
    my $zbytek = [ keys $self->{unmovable} ];
    if ( isnotempty($zbytek) ) {
       return () if( $self->analyze( $pozice, $cesty, $zbytek, $ply ));
    }
    $TAHY{$pozice} = freeze [@tahy];
    return @tahy;
}

sub reseni {
    my( $self, $tah ) = @_;
    return NO unless $tah->[POZICE] ~~ $self->{reseni};
    $self->{bestbet} = $tah->[SOL];
    $self->{bestlen} = $tah->[DELKA];
    my $level = $tah->[SOL] =~ tr/UDRL//;
    say {*STDERR} "$tah->[DELKA] [$level]: $tah->[SOL]";
	@POKR = grep {$self->postpass($_) } @POKR;
    @HEAP = grep {$self->postpass($_) } @HEAP if @HEAP;
    return YES;
}

sub seen {
    my( $self, $pozice, $sollen ) = @_;
    if ( exists $SEEN{$pozice} ) {
        return YES unless $sollen < $SEEN{$pozice};
        $SEEN{$pozice} = $sollen;
        return NO;
    }
    $SEEN{$pozice} = $sollen;
    return NO;
}

sub isseen {
    my( $self, $pozice, $sollen ) = @_;
    return NO unless exists $SEEN{$pozice};
    return YES if $sollen > $SEEN{$pozice};
    return NO;
}

sub postpass {
    my( $self, $tah ) = @_;
    return NO if $self->isinvalid( $tah->[POZICE] );
    return NO if $self->worse( $tah->[DELKA]);
    return NO if $self->isseen( $tah->[POZICE], $tah->[DELKA] );
    return YES;
}

sub pass {
    my( $self, $tah ) = @_;
    return NO if $self->isinvalid($tah->[POZICE]);
    return NO if $self->worse($tah->[DELKA]);
    return NO if $self->reseni( $tah );
    return NO if $self->seen( $tah->[POZICE],$tah->[DELKA] );
    return YES;
}

sub moves {
    my( $self, $tah ) = @_;
    my( $pozice, $solution, $sollen, $isnew, @pokr, @tahy, $sol, $level );
    return () unless $self->postpass($tah);
    $pozice = $tah->[POZICE];
    $sol    = $tah->[SOL];
    @pokr = ();
    @tahy = $self->tahy($pozice);
    return () if $self->isinvalid($pozice);
    my $newt;
    foreach my $t (@tahy) {
        $solution = $sol . $t->[SOL];
        $sollen   = length($solution);
        $newt = [$t->[POZICE],$solution,$t->[SCORE],$sollen];
        next unless $self->pass( $newt );
        $newt->[LEVEL] = $solution =~ tr/UDRL//;
        push @pokr, $newt;


    }
    return () unless @pokr;
    return  sort {$a->[SCORE] <=> $b->[SCORE]} @pokr;
}

sub info {
    my($self,$suff) = @_;
    state $oseen;
    $oseen //=  0;
    my $cseen = scalar keys %SEEN;
    
    my $pc  = ++$stat{$POKR[0]->[LEVEL]} unless $suff;
    my @mm =(minmax( map { $_->[LEVEL] } ( @POKR, @HEAP )), minmax( map { $_->[DELKA] }  ( @POKR, @HEAP ) ));

    say {*STDERR} sprintf '%s %s %8d %6d * %4s | %8d | %8d ( %3d | %3d | %3d | %4d ) %5d | %s',
      tothree( $self->{counter} ),
      strcas( $self->interval('t0') ),
      $cseen,
      $cseen - $oseen,
      $self->{bestlen} // 'N/A',
      scalar @POKR,
      scalar @HEAP,
      @mm,
      $self->{tcount},
      $suff || $pc;

      $oseen = $cseen;

}
sub uniq {
    my($self) = shift;
    return  sort {$a->[LEVEL] <=> $b->[LEVEL] || $a->[SCORE] <=> $b->[SCORE] || $a->[DELKA] <=> $b->[DELKA]}( grep {$self->postpass($_)} @_) ;
}
sub pause {
    my($self) = @_;
    return unless $self->elapsed( 'paus', 12 );

    $self->info('');
    $self->{tcount} = 0;
}


sub solve {
    my($self) = @_;
    $self->{counter} = 0;
    $self->{tcount} = 0;
    $self->chrono('t0');
    %stat = ();
    my $pozice = pozice( $self->{box}, $self->{player} );
    my $sc = $self->score( $self->{box}, $self->{player} );
    my $tah = [ $pozice, '', $sc, 0, 0 ];
    my @tahy;
    $SEEN{$pozice} = 0;
    my @add;
    @POKR = $self->moves($tah);
    @HEAP = ();
    $tah = shift(@POKR);
    while ($tah){
        @tahy = $self->moves($tah);
        if (@tahy) {
            push @HEAP, @tahy;
        }
        unless (@POKR) {
            @POKR = $self->uniq(@HEAP);
            $self->info('*');
            @HEAP = ();
        }
        $tah = shift @POKR;
    }
    continue {
        ++$self->{counter};
        ++$self->{tcount};
        $self->pause;
    }
    $self->{cas} = $self->interval('t0');
    say {*STDERR} "\nRESULT:";
    $self->info;
    say {*STDERR} $self->{bestbet} // 'UNRESOLVED';

}

1;
